home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / focus.stk < prev    next >
Encoding:
Text File  |  1996-02-22  |  4.2 KB  |  134 lines
  1. ;;;;
  2. ;;;; Focus management
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;; This software is a derivative work of other copyrighted softwares; the
  15. ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  16. ;;;;
  17. ;;;;
  18. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  19. ;;;;    Creation date: 27-Jul-1995 14:10
  20. ;;;; Last file update:  4-Aug-1995 11:15
  21. ;;;;
  22.  
  23.  
  24. ;; tk_focusNext --
  25. ;; This procedure returns the name of the next window after "w" in
  26. ;; "focus order" (the window that should receive the focus next if
  27. ;; Tab is typed in w).  "Next" is defined by a pre-order search
  28. ;; of a top-level and its non-top-level descendants, with the stacking
  29. ;; order determining the order of siblings.  The "-takefocus" options
  30. ;; on windows determine whether or not they should be skipped.
  31.  
  32. (define Tk:focus-on      (lambda (w) #t))
  33. (define Tk:focus-off    (lambda (w) #f))
  34.  
  35. (define Tk:focus-next     #f)    ; will be redefined below
  36. (define Tk:focus-prev    #f)    ; will be redefined below
  37.  
  38. ;; ----------------------------------------------------------------------
  39. ;; Default bindings for keyboard traversal.
  40. ;; ----------------------------------------------------------------------
  41.  
  42. (bind "all" "<Tab>"        (lambda (|W|) (focus (Tk:focus-next |W|))))
  43. (bind "all" "<Shift-Tab>"  (lambda (|W|) (focus (Tk:focus-prev |W|))))
  44.  
  45.  
  46. (let ()
  47.   (define (all-children w)
  48.     (let ((res '()))
  49.       (for-each (lambda (x)
  50.           (unless (equal? x (winfo 'toplevel x))
  51.               ;; x is not a toplevel
  52.               (set! res (append res (all-children x)))))
  53.         (winfo 'children w))
  54.       (cons w res)))
  55.  
  56.    (define (focusable? w)
  57.      (let ((focus #t)
  58.        (value #f))
  59.  
  60.        (if (winfo 'viewable w)
  61.        (begin
  62.          ;; 1. See if this window tells something in its :takefocus option
  63.          (if (not (catch (set! value (tk-get w :takefocus))))
  64.          ;; widget has :takefocus option
  65.          ;; Remark: :takefocus option must be a closure. But original 
  66.          ;; Tcl/Tk code can define the focus action as "0" or "1".
  67.          ;; Those values can be hard-coded in the Tk library. So take them
  68.          ;; into account
  69.          (cond 
  70.             ((boolean? value) (set! focus value))
  71.             ((closure? value) (set! focus (value w)))))
  72.  
  73.          ;; 2. See if the window is not disabled
  74.          (if focus
  75.          (if (not (catch (set! value (tk-get w :state))))
  76.              ;; widget has a :state option
  77.              (set! focus (not (equal? value "disabled")))))
  78.  
  79.          ;; 3. Claim that the window is focuable inly if it exist some
  80.          ;;    keyboard binding associated to it
  81.          (if focus
  82.          (let ((p (open-output-string)))
  83.            (display (bind w) p)
  84.            (display (bind (winfo 'class w)) p)
  85.            (let ((s (get-output-string p)))
  86.              (set! focus (or (string-find? "Key" s)
  87.                      (string-find? "Focus" s)))))))
  88.        ;; w is not visible
  89.        (set! focus #f))
  90.        focus))
  91.  
  92.   (define (find-next w l)
  93.     (let* ((len   (length l))
  94.        (index (- len (length (member w l)))))
  95.  
  96.       ;; index is the position of the current widget in l
  97.       (let loop ((i (modulo (+ index 1) len)))
  98.        (if (= i index)
  99.            ;; not found, return w
  100.            w
  101.            (let ((widget (list-ref l i)))
  102.          (if (focusable? widget)
  103.              widget
  104.              (loop (modulo (+ i 1) len))))))))
  105.  
  106.   
  107.   (set! Tk:focus-next 
  108.     (lambda (w)
  109.       (let ((all (all-children (winfo 'toplevel w))))
  110.         (if (= (length all) 1)
  111.         (car all)
  112.         (find-next w all)))))
  113.  
  114.   (set! Tk:focus-prev
  115.     (lambda (w)
  116.       (let ((all (all-children (winfo 'toplevel w))))
  117.         (if (= (length all) 1)
  118.         (car all)
  119.         (find-next w (reverse all)))))))
  120.  
  121.  
  122. (define (Tk:focus-follows-mouse)
  123.   (let ((old    (bind "all" "<Enter>"))
  124.     (script (lambda(|W| d)
  125.           (if (or (equal? d "NotifyAncestor")
  126.               (equal? d "NotifyNonlinear")
  127.               (equal? d "NotifyInferior"))
  128.               (focus |W|)))))
  129.     (add-binding "all" "<Enter>" script #f)))
  130.  
  131.  
  132.  
  133.  
  134.